Population Demographics In Canada
Graphs of population demographics in Canada using STATCAN data
Data
https://www150.statcan.gc.ca/t1/tbl1/en/cv.action?pid=1710000901
1710000901_databaseLoadingData.csv
https://www150.statcan.gc.ca/t1/tbl1/en/cv.action?pid=1710000501
1710000501_databaseLoadingData.csv
Prepare Data
# devtools::install_github("derekmichaelwright/agData")
library(agData)
library(gganimate)
library(transformr)# Prep data
myCaption <- "www.dblogr.com/ or derekmichaelwright.github.io/dblogr/ | Data: STATCAN"
myAreas <- c("Canada", "British Columbia", "Alberta", "Saskatchewan",
"Manitoba", "Ontario", "Quebec", "New Brunswick", "Nova Scotia",
"Prince Edward Island", "Newfoundland and Labrador",
"Yukon", "Northwest Territories including Nunavut",
"Northwest Territories", "Nunavut")
myAges <- c("0 to 4 years", "5 to 9 years",
"10 to 14 years", "15 to 19 years",
"20 to 24 years", "25 to 29 years",
"30 to 34 years", "35 to 39 years",
"40 to 44 years", "45 to 49 years",
"50 to 54 years", "55 to 59 years",
"60 to 64 years", "65 to 69 years",
"70 to 74 years", "75 to 79 years",
"80 to 84 years", "85 to 89 years",
"90 to 94 years", "95 to 99 years",
"100 years and over", "Median age")
#
d1 <- read.csv("1710000901_databaseLoadingData.csv") %>%
select(Year=1, Area=GEO, Unit=UOM, Value=VALUE) %>%
mutate(Area = factor(Area, levels = myAreas),
Month = substr(Year, 6, 8),
Year = substr(Year, 1,4),
Year = as.numeric(Year),
Month = as.numeric(Month),
Date = as.Date(paste(Year, Month, "01", sep = "-")))
#
d2 <- read.csv("1710000501_databaseLoadingData.csv") %>%
select(Year=1, Area=GEO, Sex, Age=Age.group, Unit=UOM, Value=VALUE) %>%
mutate(Area = factor(Area, levels = myAreas),
Age = factor(Age, levels = myAges),
Year = substr(Year, 1,4),
Year = as.numeric(Year)) %>%
filter(!is.na(Age))Population
Canada
# Prep data
xx <- d1 %>% filter(Area == "Canada")
myBreaks <- as.Date(paste0(seq(1950, 2020, by = 10), "-01-01"))
# Plot
mp <- ggplot(xx, aes(x = Date, y = Value / 1000000)) +
geom_bar(stat = "identity", fill = "darkgreen", alpha = 0.7) +
facet_wrap(Area ~ ., ncol = 4, scales = "free_y") +
scale_x_date(breaks = myBreaks, date_labels = "%Y") +
theme_agData(legend.position = "none") +
labs(y = "Million People", x = NULL, caption = myCaption)
ggsave("canada_population_1_01.png", mp, width = 6, height = 4)Saskatchewan
# Prep data
xx <- d1 %>% filter(Area == "Saskatchewan")
myBreaks <- as.Date(paste0(seq(1950, 2020, by = 10), "-01-01"))
# Plot
mp <- ggplot(xx, aes(x = Date, y = Value / 1000000)) +
geom_bar(stat = "identity", fill = "darkgreen", alpha = 0.7) +
facet_wrap(Area ~ ., ncol = 4, scales = "free_y") +
scale_x_date(breaks = myBreaks, date_labels = "%Y") +
theme_agData(legend.position = "none") +
labs(y = "Million People", x = NULL, caption = myCaption)
ggsave("canada_population_1_02.png", mp, width = 6, height = 4)All Provinces
# Prep data
myBreaks <- as.Date(paste0(seq(1950, 2020, by = 10), "-01-01"))
# Plot
mp <- ggplot(d1, aes(x = Date, y = Value / 1000000)) +
geom_bar(stat = "identity", fill = "darkgreen", alpha = 0.7) +
facet_wrap(Area ~ ., ncol = 4, scales = "free_y") +
scale_x_date(breaks = myBreaks, date_labels = "%Y") +
theme_agData(legend.position = "none",
axis.text.x = element_text(angle = 45, hjust = 1)) +
labs(y = "Million People", x = NULL, caption = myCaption)
ggsave("canada_population_1_03.png", mp, width = 10, height = 6)Median Age
Canada
# Prep data
xx <- d2 %>%
filter(Area == "Canada", Sex != "Both sexes", Age == "Median age")
# Plot
mp <- ggplot(xx, aes(x = Year, y = Value, color = Sex)) +
geom_line(size = 1.5, alpha = 0.7) +
scale_color_manual(name = NULL, values = c("palevioletred3","steelblue")) +
scale_x_continuous(minor_breaks = 1970:2025) +
scale_y_continuous(minor_breaks = 25:45) +
theme_agData(legend.position = "bottom") +
labs(title = "Median Age In Canada", x = NULL,
y = "Median Age", caption = myCaption)
ggsave("canada_population_1_04.png", mp, width = 6, height = 4)# Prep data
xx <- d2 %>%
filter(Sex != "Both sexes", Age == "Median age")
# Plot
mp <- ggplot(xx, aes(x = Year, y = Value, color = Sex)) +
geom_line() +
facet_wrap(Area ~ ., ncol = 5) +
scale_color_manual(name = NULL, values = c("palevioletred3","steelblue")) +
theme_agData(legend.position = "bottom") +
labs(title = "Median Age In Canada", x = NULL,
y = "Median Age", caption = myCaption)
ggsave("canada_population_1_05.png", mp, width = 10, height = 6)Population Pyramids
gg_PopDem_plot <- function(area = "Saskatchewan", years = 2019 ) {
# Prep data
xx <- d2 %>%
filter(Area == area, Year %in% years, Age %in% myAges)
# Plot
mp <- ggplot(xx, aes(y = Value / 1000, x = Age, fill = Sex)) +
geom_bar(data = xx %>% filter(Sex == "Males"), stat = "identity",
color = "black", alpha = 0.7) +
geom_bar(data = xx %>% filter(Sex == "Females"), stat = "identity",
color = "black", alpha = 0.7, aes(y = -Value / 1000)) +
scale_fill_manual(name = NULL, values = c("palevioletred3", "steelblue")) +
scale_y_continuous(sec.axis = sec_axis(~ .)) +
facet_grid(. ~ Year) +
theme_agData(legend.position = "bottom") +
#axis.text.x = element_blank(),axis.ticks.x = element_blank()
labs(title = area, y = NULL, x = NULL, caption = myCaption) +
coord_cartesian(ylim = c(-max(xx$Value), max(xx$Value))) +
coord_flip()
}Canada
mp <- gg_PopDem_plot(area = "Canada", years = c(1971, 1995, 2021))
ggsave("canada_population_2_01.png", mp, width = 10, height = 4)British Columbia
mp <- gg_PopDem_plot(area = "British Columbia", years = c(1971, 1995, 2021))
ggsave("canada_population_2_02.png", mp, width = 10, height = 4)Alberta
mp <- gg_PopDem_plot(area = "Alberta", years = c(1971, 1995, 2021))
ggsave("canada_population_2_03.png", mp, width = 10, height = 4)Saskatchewan
mp <- gg_PopDem_plot(area = "Saskatchewan", years = c(1971, 1995, 2021))
ggsave("canada_population_2_04.png", mp, width = 10, height = 4)Manitoba
mp <- gg_PopDem_plot(area = "Manitoba", years = c(1971, 1995, 2021))
ggsave("canada_population_2_05.png", mp, width = 10, height = 4)Ontario
mp <- gg_PopDem_plot(area = "Ontario", years = c(1971, 1995, 2021))
ggsave("canada_population_2_06.png", mp, width = 10, height = 4)Quebec
mp <- gg_PopDem_plot(area = "Quebec", years = c(1971, 1995, 2021))
ggsave("canada_population_2_07.png", mp, width = 10, height = 4)Newfoundland and Labrador
mp <- gg_PopDem_plot(area = "Newfoundland and Labrador",
years = c(1971, 1995, 2021))
ggsave("canada_population_2_08.png", mp, width = 10, height = 4)Yukon
mp <- gg_PopDem_plot(area = "Yukon", years = c(1971, 1995, 2021))
ggsave("canada_population_2_09.png", mp, width = 10, height = 4)Animated Population Pyramids
gg_PopDem_anim <- function(area = "Saskatchewan") {
# Prep data
xx <- d2 %>%
filter(Area %in% area, Age %in% myAges) %>%
mutate(Value = Value / 1000)
# Plot
mp <- ggplot(xx, aes(y = Value / 1000, x = Age, fill = Sex)) +
geom_bar(data = xx %>% filter(Sex == "Males"), stat = "identity",
color = "black", alpha = 0.7) +
geom_bar(data = xx %>% filter(Sex == "Females"), stat = "identity",
color = "black", alpha = 0.7, aes(y = -Value / 1000)) +
scale_fill_manual(name = NULL, values = c("palevioletred3", "steelblue")) +
facet_grid(. ~ Area) +
theme_agData(legend.position = "bottom",
axis.text.x = element_blank(),
axis.ticks.x = element_blank()) +
labs(title = title, y = NULL, x = NULL, caption = myCaption) +
coord_cartesian(ylim = c(-max(xx$Value), max(xx$Value))) +
coord_flip() +
# gganimate specific bits
labs(title = paste(area, '{round(frame_time)}')) +
transition_time(Year) +
ease_aes('linear')
}Canada
mp <- gg_PopDem_anim(area = "Canada")
anim_save("canada_population_gif_2_01.gif", mp,
nframes = 300, fps = 60, end_pause = 90,
width = 900, height = 600, res = 150)British Columbia
mp <- gg_PopDem_anim(area = "British Columbia")
anim_save("canada_population_gif_2_02.gif", mp,
nframes = 300, fps = 60, end_pause = 90,
width = 900, height = 600, res = 150)Alberta
mp <- gg_PopDem_anim(area = "Alberta")
anim_save("canada_population_gif_2_03.gif", mp,
nframes = 300, fps = 60, end_pause = 90,
width = 900, height = 600, res = 150)Saskatchewan
mp <- gg_PopDem_anim(area = "Saskatchewan")
anim_save("canada_population_gif_2_04.gif", mp,
nframes = 300, fps = 60, end_pause = 90,
width = 900, height = 600, res = 150)Manitoba
mp <- gg_PopDem_anim(area = "Manitoba")
anim_save("canada_population_gif_2_05.gif", mp,
nframes = 300, fps = 60, end_pause = 90,
width = 900, height = 600, res = 150)Ontario
mp <- gg_PopDem_anim(area = "Ontario")
anim_save("canada_population_gif_2_06.gif", mp,
nframes = 300, fps = 60, end_pause = 90,
width = 900, height = 600, res = 150)Quebec
mp <- gg_PopDem_anim(area = "Quebec")
anim_save("canada_population_gif_2_07.gif", mp,
nframes = 300, fps = 60, end_pause = 90,
width = 900, height = 600, res = 150)Newfoundland and Labrador
mp <- gg_PopDem_anim(area = "Newfoundland and Labrador")
anim_save("canada_population_gif_2_08.gif", mp,
nframes = 300, fps = 60, end_pause = 90,
width = 900, height = 600, res = 150)Yukon
mp <- gg_PopDem_anim(area = "Yukon")
anim_save("canada_population_gif_2_09.gif", mp,
nframes = 300, fps = 60, end_pause = 90,
width = 900, height = 600, res = 150)Sex Ratios
gg_SexRatio_plot <- function(area = "Saskatchewan", years = 2019) {
# Prep data
xx <- d2 %>%
filter(Area %in% area, Year %in% years,
Age %in% myAges, Sex %in% c("Males","Females")) %>%
spread(Sex, Value) %>%
mutate(Value = Males - Females,
Group = ifelse(Value < 0, "More Females", "More Males"))
# Plot
ggplot(xx, aes(y = Value, x = Age, fill = Group)) +
geom_bar(stat = "identity", color = "black", alpha = 0.7) +
scale_fill_manual(name = NULL, values = c("darkred","steelblue")) +
scale_y_continuous(sec.axis = sec_axis(~ .)) +
facet_grid(. ~ Year) +
theme_agData(legend.position = "bottom") +
labs(title = area, subtitle = "Females - Males",
y = NULL, x = NULL, caption = myCaption) +
coord_cartesian(ylim = c(-max(xx$Value), max(xx$Value))) +
coord_flip()
}Canada
mp <- gg_SexRatio_plot(area = "Canada", years = c(1971, 1995, 2021))
ggsave("canada_population_3_01.png", mp, width = 10, height = 4)British Columbia
mp <- gg_SexRatio_plot(area = "British Columbia", years = c(1971, 1995, 2021))
ggsave("canada_population_3_02.png", mp, width = 10, height = 4)Alberta
mp <- gg_SexRatio_plot(area = "Alberta", years = c(1971, 1995, 2021))
ggsave("canada_population_3_03.png", mp, width = 10, height = 4)Saskatchewan
mp <- gg_SexRatio_plot(area = "Saskatchewan", years = c(1971, 1995, 2021))
ggsave("canada_population_3_04.png", mp, width = 10, height = 4)Manitoba
mp <- gg_SexRatio_plot(area = "Manitoba", years = c(1971, 1995, 2021))
ggsave("canada_population_3_05.png", mp, width = 10, height = 4)Ontario
mp <- gg_SexRatio_plot(area = "Ontario", years = c(1971, 1995, 2021))
ggsave("canada_population_3_06.png", mp, width = 10, height = 4)Quebec
mp <- gg_SexRatio_plot(area = "Quebec", years = c(1971, 1995, 2021))
ggsave("canada_population_3_07.png", mp, width = 10, height = 4)Newfoundland and Labrador
mp <- gg_SexRatio_plot(area = "Newfoundland and Labrador",
years = c(1971, 1995, 2021))
ggsave("canada_population_3_08.png", mp, width = 10, height = 4)Yukon
mp <- gg_SexRatio_plot(area = "Yukon", years = c(1971, 1995, 2021))
ggsave("canada_population_3_09.png", mp, width = 10, height = 4)Age Line Graphs
Males vs. Females
# Prep data
xx <- d2 %>%
filter(Area == "Canada", Sex %in% c("Males","Females"), Age %in% myAges)
# Plot
mp <- ggplot(xx, aes(x = Year, y = Value / 1000000, color = Sex)) +
geom_line(size = 1, alpha = 0.7) +
facet_wrap(Age ~ ., scales = "free_y", ncol = 6) +
scale_color_manual(name = NULL, values = c("palevioletred3","steelblue")) +
theme_agData(legend.position = "bottom",
axis.text.x = element_text(angle = 45, hjust = 1)) +
labs(title = "Canadian Population Dynamics",
y = "Million People", x = NULL, caption = myCaption)
ggsave("canada_population_4_01.png", mp, width = 12, height = 6)Animation
xx <- d2 %>%
filter(Area == "Canada", Sex %in% c("Males","Females"), !is.na(Value))
# Plot
mp <- ggplot(xx, aes(x = Year, y = Value / 1000000, color = Sex, group = Sex)) +
geom_line(size = 1, alpha = 0.7) +
scale_color_manual(name = NULL, values = c("palevioletred3","steelblue")) +
theme_agData(legend.position = "bottom") +
labs(y = "Million People", x = NULL, caption = myCaption) +
labs(title = paste("Canadian Population Dynamics -", '{closest_state}')) +
transition_states(Age, transition_length = 1, state_length = 1) +
ease_aes('linear')
anim_save("canada_population_gif_4_01.gif", mp,
nframes = 300, fps = 60,
width = 900, height = 600, res = 150)Old vs Young
Canada
# Prep data
xx <- d2 %>%
filter(Sex %in% c("Males", "Females")) %>%
mutate(Group = ifelse(Age %in% myAges[14:21], "old", "Young")) %>%
group_by(Year, Area, Sex, Group) %>%
summarise(Value = sum(Value, na.rm = T)) %>%
ungroup() %>%
group_by(Year, Area, Sex) %>%
mutate(Total = sum(Value, na.rm = T)) %>%
ungroup() %>%
mutate(Percent = 100 * Value / Total)
# Plot
mp <- ggplot(xx %>% filter(Area == "Canada", Group == "Young"),
aes(x = Year, y = Percent, color = Sex)) +
geom_line(alpha = 0.7, size = 1) +
scale_color_manual(name = NULL, values = c("palevioletred3", "steelblue")) +
ylim(c(70,100)) +
theme_agData(legend.position = "bottom") +
labs(title = "Canada - Percent of population under 65", x = NULL)
ggsave("canada_population_5_01.png", mp, width = 6, height = 4)Provinces
# Plot
mp <-ggplot(xx %>% filter(Area != "Canada", Group == "Young"),
aes(x = Year, y = Percent, color = Sex)) +
geom_line(alpha = 0.7, size = 1) +
scale_color_manual(name = NULL, values = c("palevioletred3", "steelblue")) +
facet_wrap(Area ~ ., ncol = 5) +
ylim(c(70,100)) +
theme_agData(legend.position = "bottom") +
labs(title = "Canada - Percent of population under 65", x = NULL)
ggsave("canada_population_5_02.png", mp, width = 12, height = 6)2021
# Prep data
xx <- xx %>% filter(Year == 2021, Group == "Young")
# Plot
mp <- ggplot(xx, aes(x = Area, y = Percent, fill = Sex)) +
geom_bar(stat = "identity", position = "dodge", color = "black", alpha = 0.7) +
scale_fill_manual(name = NULL, values = c("palevioletred3", "steelblue")) +
theme_agData(legend.position = "bottom",
axis.text.x = element_text(angle = 45, hjust = 1)) +
labs(title = "Canada - Percent of population under 65", x = NULL)
ggsave("canada_population_5_03.png", mp, width = 6, height = 4)